shr: Correct SVG attribute case

* lisp/net/shr.el (shr-correct-attribute-case): New constant.
(shr-correct-dom-case): New function to correct SVG attribute case.
(shr-tag-svg): Correct SVG attribute cases before using them.
This commit is contained in:
Sacha Chua 2024-01-26 08:54:03 -05:00 committed by Eli Zaretskii
parent 849f8c1d49
commit 169c704d74

View file

@ -1437,13 +1437,85 @@ ones, in case fg and bg are nil."
(shr-dom-print elem)))))
(insert (format "</%s>" (dom-tag dom))))
(defconst shr-correct-attribute-case
'((attributename . attributeName)
(attributetype . attributeType)
(basefrequency . baseFrequency)
(baseprofile . baseProfile)
(calcmode . calcMode)
(clippathunits . clipPathUnits)
(diffuseconstant . diffuseConstant)
(edgemode . edgeMode)
(filterunits . filterUnits)
(glyphref . glyphRef)
(gradienttransform . gradientTransform)
(gradientunits . gradientUnits)
(kernelmatrix . kernelMatrix)
(kernelunitlength . kernelUnitLength)
(keypoints . keyPoints)
(keysplines . keySplines)
(keytimes . keyTimes)
(lengthadjust . lengthAdjust)
(limitingconeangle . limitingConeAngle)
(markerheight . markerHeight)
(markerunits . markerUnits)
(markerwidth . markerWidth)
(maskcontentunits . maskContentUnits)
(maskunits . maskUnits)
(numoctaves . numOctaves)
(pathlength . pathLength)
(patterncontentunits . patternContentUnits)
(patterntransform . patternTransform)
(patternunits . patternUnits)
(pointsatx . pointsAtX)
(pointsaty . pointsAtY)
(pointsatz . pointsAtZ)
(preservealpha . preserveAlpha)
(preserveaspectratio . preserveAspectRatio)
(primitiveunits . primitiveUnits)
(refx . refX)
(refy . refY)
(repeatcount . repeatCount)
(repeatdur . repeatDur)
(requiredextensions . requiredExtensions)
(requiredfeatures . requiredFeatures)
(specularconstant . specularConstant)
(specularexponent . specularExponent)
(spreadmethod . spreadMethod)
(startoffset . startOffset)
(stddeviation . stdDeviation)
(stitchtiles . stitchTiles)
(surfacescale . surfaceScale)
(systemlanguage . systemLanguage)
(tablevalues . tableValues)
(targetx . targetX)
(targety . targetY)
(textlength . textLength)
(viewbox . viewBox)
(viewtarget . viewTarget)
(xchannelselector . xChannelSelector)
(ychannelselector . yChannelSelector)
(zoomandpan . zoomAndPan))
"Attributes for correcting the case in SVG and MathML.
Based on https://html.spec.whatwg.org/multipage/parsing.html#parsing-main-inforeign .")
(defun shr-correct-dom-case (dom)
"Correct the case for SVG segments."
(dolist (attr (dom-attributes dom))
(when-let ((rep (assoc-default (car attr) shr-correct-attribute-case)))
(setcar attr rep)))
(dolist (child (dom-children dom))
(shr-correct-dom-case child))
dom)
(defun shr-tag-svg (dom)
(when (and (image-type-available-p 'svg)
(not shr-inhibit-images)
(dom-attr dom 'width)
(dom-attr dom 'height))
(funcall shr-put-image-function (list (shr-dom-to-xml dom 'utf-8)
'image/svg+xml)
(funcall shr-put-image-function
(list (shr-dom-to-xml (shr-correct-dom-case dom) 'utf-8)
'image/svg+xml)
"SVG Image")))
(defun shr-tag-sup (dom)